Visual Basic Source Code/Visual Basic Source Code.iso/vbsource/vbdb/dbaccess.bas

BASIC Source File | 1995-09-06 | 16.0 KB | 600 lines

'
'VBDB version 1.0 for Visual Basic 1.0 and Windows 3.0
'(C)1991 Marquis Computing. All Rights Reserved.
'
'Client interface module for VBDB version 1.10.
'

DefInt A-Z

Dim DBA_Data  As String
Dim DBA_Mesg  As String
Dim DBA_Stat  As Integer
Dim ClientID As String

Const True = -1
Const False = 0

Sub StatusDBF (Handle, FileName$, dbftype$, DBTPtr, NumRecs&, NumFlds, RecLen, UpDate$, Status)

    '
    'Returns information about a database
    '

    '--- verify handle is valid
    If Handle < 1 Then Status = 5: Exit Sub

    '--- use DDE Server
    DBAccess "STATUSDBF," + Str$(Handle)

    '--- return values
    If Status = 0 Then
        ReDim Parsed(8)  As String
        ParseString DBA_Data, ",", Parsed()
        FileName$ = Parsed(1)
        dbftype$ = Parsed(2)
        DBTPtr = Val(Parsed(3))
        NumRecs& = Val(Parsed(4))
        NumFlds = Val(Parsed(5))
        RecLen = Val(Parsed(6))
        UpDate$ = Parsed(7)
    End If

End Sub

Sub CloseDBF (Handle, Status, Mode)

    '
    'Asks the DDE server to close a database file
    '

    '--- verify handle is valid
    If Handle < 1 Then Status = 5: Exit Sub

    '--- use DDE Server
    DBAccess "CLOSEDBF," + Str$(Handle) + "," + Str$(Mode)     'use DDE

    '--- return value(s)
    Status = DBA_Stat                       'set status

End Sub

Sub CloseNDX (Index, Status)
    '
    'Closes an index
    '

    '--- verify handle is valid
    If Index < 1 Then Status = 5: Exit Sub

    '--- use DDE Server
    DBAccess "CLOSENDX," + Str$(Index)

    '--- return value(s)
    Status = DBA_Stat                       'set status

End Sub

Sub CommitSTR (Handle, Status)

    '
    'Used to write the database header to disk
    '

    '--- verify handle is valid
    If Handle < 1 Then Status = 5: Exit Sub

    '--- use DDE Server
    DBAccess "CREATEDBF," + Str$(Handle)    'use DDE

    '--- return value(s)
    Status = DBA_Stat                       'set status

End Sub

Sub CreateDBF (NewDbfName$, Handle, Fld$(), Mode, Status)

    '
    'High level routine to create a then
    'open a database. Combines the functions of
    '
    '   OpenDBF,
    '   DefineSTR,
    '   CommitSTR,
    '   CloseDBF and
    '   OpenDBF
    '
    'all in one routine.
    '
    'NOTE:  Database is defined based on array Flds$().
    '       I strongly urge you to use DefineDatabase
    '       to develop the Flds$() definition array
    '       for you!
    '
    '

    '--- open file / erase exiting (if any)
    OpenDBF Handle, Status, NewDbfName$, dbftype, 2
    If Status Then Exit Sub

    '--- get no. fields
    NumFlds = Val(Fld$(0, 0))

    '--- add fields
    For FldNum = 1 To NumFlds
        FldName$ = LTrim$(RTrim$(UCase$(Fld$(FldNum, 4))))
        FldType$ = Left$(UCase$(Fld$(FldNum, 3)), 1)
        FldLen = Val(Fld$(FldNum, 2))
        Dec = Val(Fld$(FldNum, 1))
        DefineSTR Handle, FldNum, FldName$, FldType$, FldLen, Dec
    Next

    '--- save structure to file
    CommitSTR Handle, Status

    '--- close it
    CloseDBF Handle, Status, 0

    '--- open it up
    OpenDBF Handle, Status, NewDbfName$, dbftype, Mode

End Sub

Sub DBAccess (CmdStr$)

    '
    'Low-level routine which actually does the DDE
    'exchange with the server.
    '

    '--- check link
    'If Not DBALinkUp() Then Exit Sub

    '--- send DDE command
    DBA.db.LinkExecute CmdStr$

    '--- assign server response(s)
    DBA_Data = DBA.db.Text
    DBA_Mesg = DBA.message.Text
    DBA_Stat = Val(DBA.errorstat.Text)

End Sub

Function DBALinkUp ()

    '
    'Returns True (-1) if a client-server database link
    'is up, False (0) if link is down.
    '

    On Error GoTo LinkUpError
    DBA.db.LinkExecute "Status"
    DBALinkUp = -1
    On Error GoTo 0
    Exit Function

LinkUpError:
    DBALinkUp = 0
    On Error GoTo 0
    Resume LinkUpErrorOut
LinkUpErrorOut:
End Function

Function DBALoaded ()

    '
    'Checks to see if server is already running --
    'use DBALinkUp to see if DDE channel is
    'operational.
    '

    On Error GoTo VBDBLoadedError
    AppActivate "VBDB"
    On Error GoTo 0
    DBALoaded = -1
    Exit Function

VBDBLoadedError:
    On Error GoTo 0
    DBALoaded = 0
    Resume VBDBLoadedErrorOut

VBDBLoadedErrorOut:

End Function

Sub DefineSTR (Handle, FldNum, FldName$, FldType$, FldLen, Decimal)

    '
    'Used to send information to the DDE server to
    'define a database. It called once for each field.
    '

    '--- verify handle is valid
    If Handle < 1 Then Status = 5: Exit Sub

    '--- use DDE Server
    DBAccess "DEFSTR," + Str$(Handle) + "," + Str$(FldNum) + "," + FldName$ + "," + FldType$ + "," + Str$(FldLen) + "," + Str$(Decimal)

    '--- return value(s)
    Status = DBA_Stat

End Sub

Sub GetFLD (Handle, Status, FldNum, FldName$, FldData$, RecData$)

    '
    'Returns a fields data from a database. FldNum has precedence
    'over FldName$. FldNum indicates a field number to retrieve,
    'if FldNum > 0. FldName$ indicates a field name to get, if FldNum
    'is 0.
    '
    'Returns FldNum, FldName$, FldData$ and Status
    '

    '--- verify handle is valid
    If Handle < 1 Then Status = 5: Exit Sub

    '--- use DDE Server
    DBAccess "GETFLD," + Str$(Handle) + "," + Str$(FldNum) + "," + FldName$ + "," + RecData$

    '--- return value(s)
    FldData$ = DBA_Data
    Status = DBA_Stat

End Sub

Sub GetFLDS (Handle, Status, NumFlds, Flds$(), RecNum&)
    '
    'Returns the number of fields in a record and
    'parses the record into an array. Faster than
    'Using GetREC and then using multiple GetFLD
    'calls. Passed RecNum& -- returns Flds$() which contains
    'all the fields data.
    '
    DBAccess "GETFLDS," + Str$(Handle) + "," + Str$(RecNum&)
    Status = DBA_Stat: If Status > 0 Then Exit Sub
    ParseString DBA_Data, ",", Flds$()
    NumFlds = Val(Flds$(1))
    For X = 1 To NumFlds - 1
        Flds$(X) = Flds$(X + 1)
    Next
End Sub

Sub GetKEY (Index, Status, Key$, Record&, Mode)

    '
    'Finds a key in an index
    '

    '--- verify handle is valid
    If Index < 1 Then Status = 5: Exit Sub

    '--- use DDE Server
    DBAccess "GETKEY," + Str$(Index) + "," + Key$ + "," + Str$(Record&) + "," + Str$(Mode)

    '--- return value(s)
    If DBA_Mesg = "key found" Then
        Record& = DBA_Stat              'record no. passed via stat
        DBA_Stat = 0                    'status is 0
        Status = 0                      '   "    " "
    Else
        Status = DBA_Stat
    End If

    Key$ = DBA_Data                 'actual key found

End Sub

Sub GetREC (Handle, Status, Rec&, RecData$)

    '
    'Returns a DBF record from Handle in RecData$
    '

    '--- verify handle is valid
    If Handle < 1 Then Status = 5: Exit Sub

    '--- use DDE Server
    DBAccess "GETREC," + Str$(Handle) + "," + Str$(Rec&)

    '--- return value(s)
    RecData$ = DBA_Data
    Status = DBA_Stat

End Sub

Function InCount (StringToCount As String, Item As String) As Integer

        '
        'Counts up the number of times Item$ occurs in StringToCount$.
        '
        'Another interesting (to me) use of extra code to speed up a
        'time-critical operation. Below, I use code short-circuiting
        'techniques as well as loop counter modification and STEP
        'options to make this FOR...NEXT loop the FASSSSTEST it can
        'be!
        '

        '--- Get these now to save time later
        Reps = Len(StringToCount$)      'size of string
        ItemLen = Len(Item$)               'use this to be able to find blocks

        '--- go for it
        For X = 1 To Reps Step ItemLen     'STEP Item for speed!
          '--- look for Item$
          OffSet = InStr(X, StringToCount$, Item$)
          If OffSet Then
            '--- got a copy of Item$ so bump counter
            Count = Count + 1
            '---modify X to jump ahead to OffSet (adds speed)
            X = OffSet
          Else
            '--- no more so lets boogy (short-circuit)
            Exit For
          End If
        Next

        '---assign function
        InCount = Count

End Function

Function LogOffServer ()

     '
     'Low-level routine that closes down a
     'clients session with the server. Returns
     'FALSE (0) if link not removed or TRUE (-1)
     'if link removed.
     '

     If Not DBALinkUp() Then Exit Function

     '--- turn off links
     DBA.db.LinkMode = False
     DBA.message.LinkMode = False
     DBA.errorstat.LinkMode = False

     '--- close server if only app using it
     Server$ = "VBDB"
     AppActivate Server$
     SendKeys "%{F4}", -1

     LogOffServer = -1

End Function

Function LogonServer ()

    '
    'Low-level routine that sets-up a "hot" DDE
    'link between the server and client.
    'Returns TRUE (-1) if link setup or FALSE (0)
    'if link fails.

    Screen.MousePointer = 11
    'On Error Resume Next

    '--- some variables
    Topic$ = "VBDB|XFER"
    Nul$ = ""
    TimeOut = 100
    LoadMode = 4
    Hot = 1
    Cold = 2

    If Not DBALoaded() Then
        '--- load the server engine
        dummy = Shell("VBDB", LoadMode)             'load server engine
        If dummy = False Then
            LogonServer = False
            Screen.MousePointer = False
            Exit Function     'can't open server
        End If
        dummy = DoEvents()                  'get VBDB running
    End If

    '--- build client-server
    DBA.db.LinkMode = False                 'disable link
    DBA.db.LinkTimeout = TimeOut            'time-out
    DBA.db.LinkTopic = Topic$               'connect to database server
    DBA.db.LinkItem = "PastFld"             'connect to pastefield
    DBA.db.LinkMode = Hot                   'hot link

    DBA.message.LinkMode = False            'disable link
    DBA.message.LinkTimeout = TimeOut       'time-out
    DBA.message.LinkTopic = Topic$          'connect to database server
    DBA.message.LinkItem = "Message"        'connect to pastefield
    DBA.message.LinkMode = Hot              'hot link

    DBA.errorstat.LinkMode = False          'disable link
    DBA.errorstat.LinkTimeout = TimeOut     'time-out
    DBA.errorstat.LinkTopic = Topic$        'connect to database server
    DBA.errorstat.LinkItem = "ErrorStat"    'connect to pastefield
    DBA.errorstat.LinkMode = Hot            'hot link

    DBA.ClientID.LinkMode = False           'disable link
    DBA.ClientID.LinkTimeout = TimeOut      'time-out to 10s
    DBA.ClientID.LinkTopic = Topic$         'connect to database server
    DBA.ClientID.LinkItem = "ClientInfo"    'connect to pastefield
    DBA.ClientID.LinkMode = Cold            'cold link

    '--- init link
    DBAccess "CLIENT," + Str$(DBA.hwnd)
    Status = DBA_Stat

    '--- clean up & exit
    Screen.MousePointer = 0
    'On Error GoTo 0
    If Status = 0 Then LogonServer = -1

End Function

Sub OpenDBF (Handle, Status, FileName$, dbftype, Mode)

    '
    'Opens a database via the server, returning Handle.
    '
    'NOTE:  Handle CANNOT be used to access the file via VB!
    '       Handle MUST only be used via the DBACCESS routines!
    '
    'NOTE:  dbftype is a dummy paramater used to provide
    '       call compatibility with other popular database
    '       programming libraries.


    '--- use DDE Server
    DBAccess "OPENDBF," + FileName$ + "," + Str$(Mode)

    '--- assign return values
    Status = DBA_Stat
    Handle = Val(DBA_Data)

End Sub

Sub OpenNDX (File, Status, NDXName$, NDXtype, NDXmode, KeyExp$, KeyLen, KeyType, Mode)

    '
    'Opens an index
    '

    '--- use DDE Server
    DBAccess "OPENNDX," + NDXName$ + "," + Str$(Mode)
    Status = DBA_Stat
    File = Val(DBA_Data)

End Sub

Sub ParseString (ToParse As String, Seperator As String, Parsed() As String)

        '
        'Parses a string up into an array.
        '
        'Uses Seperator$ as the item seperator, usually a / or perhaps a
        'space or whatever. Parsed$() must be dimmed to proper size before
        'calling this function!
        '
        'Interesting use of the modification of a loop counter variable.
        'below, I modify the FOR...NEXT counter to speed up the routine.
        '
        'NOTE: That due to my desire to make this a FAST sub routine, it
        '      has more code than you might expect. I use INSTR
        '      to find items instead of looking at each item-block
        '      one-by-one. Net? VERY FAST, but a little code-heavy. -hm
        '

        '---count up Seperator$ in ToParse$
        NumEls = InCount(ToParse$, Seperator$) + 1
        If NumEls = 0 Then Exit Sub             'exit if nothing to count
        ReDim Parsed$(NumEls)

        '--- get size of ToParse$ once, saves time.
        Reps = Len(ToParse$)
        Ft = 1                  'offset for start of line

        '--- step through it
        For X = 1 To Reps

          '--- look for seperator
          OffSet = InStr(X, ToParse$, Seperator$)

          If OffSet Then        'we got one

             '--- pop total counter
             Arg = Arg + 1

             '--- look for another seperator after this one (INSTR(X+1...)
             NextSep = InStr(X + 1, ToParse$, Seperator$)

             If NextSep Then

                '---there is another one so read from this seperator to
                '   the next one.
                Parsed$(Arg) = Mid$(ToParse$, X + 1 - Ft, NextSep - X - 1 + Ft)

                '---here I modify loop counter X so that we jump ahead
                '   in the string, this saves a lot of time.
                X = NextSep - 1

             Else

                '---last one; read from / to end of string
                Parsed$(Arg) = Mid$(ToParse$, X + 1, Len(ToParse$) - X)

                '---exit loop as there is nothing else left to read!
                Exit For

             End If     'nextsep

          End If        'offset

          Ft = 0        'lose offset for start of line

        Next            'pass

End Sub

Sub PutFLD (Handle, Status, FldNum, FldName$, FldData$, RecData$)

    '
    'Writes a field into a record
    '

    '--- verify handle is valid
    If Handle < 1 Then Status = 5: Exit Sub

    '--- use DDE Server
    DBAccess "PUTFLD," + Str$(Handle) + "," + Str$(FldNum) + "," + FldName$ + "," + FldData$ + "," + RecData$

    '--- return value(s)
    RecData$ = DBA_Data
    Status = DBA_Stat

End Sub

Sub PutRec (Handle, Status, Record&, RecData$)

    '
    'Writes a record into the database
    '

    '--- verify handle is valid
    If Handle < 1 Then Status = 5: Exit Sub

    '--- use DDE server
    DBAccess "PUTREC," + Str$(Handle) + "," + Str$(Record&) + "," + RecData$

    '--- return value(s)
    Status = DBA_Stat
    If Status = 0 Then Record& = Val(DBA_Data)

End Sub

Sub ReturnSTR (File, Status, FldNum, FldName$, FldType$, FldLen, Decimal)

    '
    'Returns information about a given field.
    'Pass FldNum or FldName$ -- if FldNum is >0 then
    'it will be used over FldName$.
    '

    If File < 1 Then Status = 5: Exit Sub

    DBAccess "RETURNSTR," + Str$(File) + "," + Str$(FldNum) + "," + FldName$

    If DBA_Stat = 0 Then
        ReDim Parsed(6) As String
        ParseString DBA_Data, ",", Parsed()
        FldNum = Val(Parsed(1))
        FldName$ = Parsed(2)
        FldLen = Val(Parsed(3))
        FldType$ = Parsed(4)
        Decimal = Val(Parsed(5))
    End If

    Status = DBA_Stat

End Sub